signature SEMANT =
sig
    val transProg : Absyn.exp -> unit
end

structure Semant : SEMANT =
struct
    structure A = Absyn
    structure E = ErrorMsg
    structure S = Symbol
    structure T = Types
    structure X = Translate
    structure V = Env
    structure M = Temp
    structure C = FindEscape

    val escapeEnv= C.escapeEnv   

    fun typeError pos msg = E.error pos ("type error: " ^ msg)
    structure Translate = struct type exp = unit end
    type expty = {exp: Translate.exp, ty: T.ty}

    fun commaSep [] = ""
      | commaSep [s] = s
      | commaSep (s::ss) = s ^ ", " ^ (commaSep ss)
			   
    type expty = { exp : A.exp, ty : T.ty }
    val looplevel = ref 0

    fun unparseTy T.INT = "int"
      | unparseTy T.STRING = "string"
      | unparseTy T.UNIT = "unit"
      | unparseTy T.NIL = "nil"
      | unparseTy (T.NAME (name, ref NONE)) = "unknown type " ^ (S.name name)
      | unparseTy (T.NAME (name, ref (SOME _))) = S.name name
      | unparseTy (T.ARRAY (ty, _)) = "[" ^ (unparseTy ty) ^ "]"
      | unparseTy (T.RECORD (sts, _)) = "{" ^ (commaSep (map (fn (name, ty) => (S.name name) ^ ":" ^ (unparseTy ty)) sts)) ^ "}"

    (* checkInt : expty * pos -> unit *)
    fun checkInt ({exp,ty}, pos) = 
    	case ty of T.INT => ()
	| _ => typeError pos("integer required") 

    (* comparable : expty * expty -> boolean *)
    fun comparable (t1,t2 ) = 
    	case (t1,t2) of
 	      (T.INT,T.INT) => true
	      |(T.STRING ,T.STRING) => true  
	     

    (* assignable : expty * expty -> boolean *)
    fun assignable (t1,t2 ) = 
    	case (t1,t2) of
 	      (T.NIL,T.RECORD(_)) => true
	      |(T.RECORD(_) ,T.NIL) => true
	      |(T.RECORD(_,ref1), T.RECORD(_,ref2))=> ref1=ref2
	      |(T.ARRAY(_,ref1), T.ARRAY(_,ref2))=> ref1=ref2
	      |(t1,t2)=> comparable(t1,t2)
	     
    	
    fun actualTy (T.NAME(s, ty) , pos)=
    	( case !ty of 
		 NONE => (E.error pos "Undefined type"; T.INT)
		 |SOME t => actualTy (t, pos))
	|actualTy (t,pos)= t

    fun typelookup tenv n  pos= 
    	let val tyoption=S.look(tenv, n)
	in  
			 ( case tyoption of
	     	  	   	 NONE => (typeError pos "type is not defined"; T.INT)
	    	  		 |SOME ty2=> ty2 )
	 end

      

    (* transTy : tenv * Absyn.ty -> Types.ty *)
    fun transTy (tenv, t)=
    	let fun recordtys []=[]
	    	|recordtys ({name=n,escape,typ,pos}:: fields)=
		(n,typelookup tenv n pos ):: recordtys  fields 
	in	
		case t of
		A.NameTy (n, pos)=> typelookup tenv n pos			 
		|A.RecordTy fields=> T.RECORD (recordtys fields, ref())
		|A.ArrayTy (n,pos)=>T.ARRAY(typelookup tenv n pos, ref())
	end
	    				       
    (* transDec : (tenv * venv * dec) -> (venv, tenv) *)
 and 
 transDec (venv, tenv, A.VarDec{name=name, escape=escape ,typ=NONE, init=init, pos},level) =
	let val  {exp, ty} = transExp(venv, tenv, level) init 
	     val escapeoption = S.look (escapeEnv,name)
	in
	    ( if ty=T.NIL then typeError pos "Type should not be NIL" else ();
	         ( case escapeoption of 
		   SOME (lev, escref) =>  {tenv=tenv,venv=S.enter(venv, name, V.VarEntry({access=X.allocLocal level (!escref),ty=ty}))})
                 )
	end
     |transDec (venv, tenv, A.VarDec{name=name,escape= escape ,typ=SOME(symbol1, pos), init=init, pos=pos1},level) =
	let val  {exp, ty} = transExp(venv, tenv,level) init
	    val tyoption = S.look (tenv,symbol1)
             val escapeoption = S.look (escapeEnv,name)
	in
	    ( case tyoption of
	     	   NONE => typeError pos "type is not defined"
	    	   |SOME ty2=>  if ty<>ty2 then typeError pos1  "types don't match" else ();
	      (case escapeoption of 
		   SOME (lev, escref) => {tenv=tenv,venv=S.enter(venv, name, V.VarEntry{access=X.allocLocal level(!escref),ty=ty})  } ))
	end


      | transDec (venv, tenv, A.TypeDec [{name, ty, pos} ],_)=
	{venv=venv,tenv=S.enter(tenv, name, transTy(tenv, ty))}


      | transDec (venv, tenv, A.FunctionDec fundecs,level) =      
	let fun enterFun ({name, params=params, body, pos=pos1, result=result},venvold)=
	    	let 
		    fun gettype(ty)=
		    (case ty of 
		    	  NONE=> T.UNIT
			  |SOME(rt, pos) => let  val SOME(result_ty) = S.look(tenv, rt) in result_ty end)

	         val result_ty= gettype (result)
	    	 fun transParam {name,escape=escape, typ, pos} = case S.look(tenv, typ)
					      of SOME t => {name=name, ty=t}
	         val params' = map transParam params
		 val escapes = map (fn param => !(#escape param)) params
		 val funlabel= M.newlabel()
	    	 val venvnew = S.enter(venvold, name, V.FunEntry {level=X.newLevel{
										parent=level,
										name=funlabel,
										formals=escapes},label=funlabel,formals=map #ty params', result=result_ty})	    	
	    	 in 
	       	    venvnew
	    	 end	      
	    val venvfundecs = foldl enterFun venv fundecs  

	    fun declareFun ({name, params=params, body, pos=pos1, result=SOME(rt, pos)},venvfndecs)=
	    	let 
		    val SOME(result_ty) = S.look(tenv, rt)
	    	    fun transParam {name,escape=escape, typ, pos} = case S.look(tenv, typ)
					      of SOME t => {name=name, ty=t,escape=escape}
	       	     val params' = map transParam params	   
	    	     fun enterParam ({name, ty,escape}, venv) = S.enter (venv, name, V.VarEntry{access=X.allocLocal level(!escape),ty= ty})
	    	     val venv'' = foldl enterParam venvfndecs  params'
		in ( transExp(venv'', tenv,level) body
	   	   ; venvfndecs
	   	   )
		end
	
	    val   venvtenv=foldl declareFun venvfundecs fundecs	

	in 
	   {venv=venvfundecs, tenv=tenv}
	end
	     
	
							    
    (* transExp : (venv, tenv -> exp -> expty *)
    

and
  transExp (venv, tenv, level) =
        let fun trExp (A.NilExp)= {exp=(), ty=T.NIL}
	      |trExp (A.IntExp i)=  {exp=(), ty=T.INT}
	      |trExp (A.StringExp(s,pos))= {exp=(), ty=T.STRING}
              |trExp (A.OpExp{left,oper=A.PlusOp,right,pos}) =
		( checkInt (trExp(left), pos)
		; checkInt (trExp( right), pos)
		; {exp = (), ty = T.INT}
		)
	      | trExp (A.OpExp{left,oper=A.MinusOp,right,pos}) =
		( checkInt (trExp(left), pos)
		; checkInt (trExp( right), pos)
		; {exp = (), ty = T.INT}
		)
	      |trExp (A.OpExp{left,oper=A.TimesOp,right,pos}) =
		( checkInt (trExp(left), pos)
		; checkInt (trExp( right), pos)
		; {exp = (), ty = T.INT}
		)
	      |trExp (A.OpExp{left,oper=A.DivideOp,right,pos}) =
	      	( checkInt (trExp(left), pos)
		; checkInt (trExp(right), pos)
		; {exp = (), ty = T.INT}
		)
	      |trExp (A.OpExp{left,oper=A.EqOp,right,pos}) =
	      	 (let val {exp=_, ty=ty1}=trExp (left);
		     	 val {exp=_, ty=ty2}=trExp(right);
		 in
			if assignable(ty1, ty2) then ()
                 	else typeError pos  "types don't match"; {exp=(), ty=T.INT}		 
		 end)
	      |trExp (A.OpExp{left,oper=A.NeqOp,right,pos}) =
	      	(let val {exp=_, ty=ty1}=trExp (left);
		     	 val {exp=_, ty=ty2}=trExp(right);
		 in
			if assignable(ty1, ty2) then ()
                 	else typeError pos  "types don't match"; {exp=(), ty=T.INT}		 
		 end)	
	      |trExp (A.OpExp{left,oper=A.LtOp,right,pos}) =
	      	(let val {exp=_, ty=ty1}=trExp (left);
		     	 val {exp=_, ty=ty2}=trExp(right);
		 in
			if comparable(ty1, ty2) then ()
                 	else typeError pos  "types don't match"; {exp=(), ty=T.INT}		 
		 end)
	      |trExp (A.OpExp{left,oper=A.LeOp,right,pos}) =
	      	(let val {exp=_, ty=ty1}=trExp (left);
		     	 val {exp=_, ty=ty2}=trExp(right);
		 in
			if comparable(ty1, ty2) then ()
                 	else typeError pos  "types don't match"; {exp=(), ty=T.INT}		 
		 end)
	      |trExp (A.OpExp{left,oper=A.GtOp,right,pos}) =
	      	(let val {exp=_, ty=ty1}=trExp (left);
		     	 val {exp=_, ty=ty2}=trExp(right);
		 in
			if comparable(ty1, ty2) then ()
                 	else typeError pos  "types don't match"; {exp=(), ty=T.INT}		 
		 end)
	      |trExp (A.OpExp{left,oper=GeOp,right,pos}) =
	      	(let val {exp=_, ty=ty1}=trExp (left);
		     	 val {exp=_, ty=ty2}=trExp(right);
		 in
			if comparable(ty1, ty2) then ()
                 	else typeError pos  "types don't match"; {exp=(), ty=T.INT}		 
		 end)

	      |trExp (A.IfExp{test, then', else', pos}) =
	      	(checkInt (trExp test, pos);
		case else' of 
		SOME else'=>
		     let val {exp=_, ty=ty1}=trExp (then');
		     	 val {exp=_, ty=ty2}=trExp(else');
		     in
			if assignable(ty1, ty2) then ()
                     	     else typeError pos "IF  branches don't match";
			 {exp=(), ty=ty1}	      
		     end	    
		    		
		| NONE => 
		   let val {exp=_, ty=ty1}=trExp(then');
		   in
		    if ty1=T.UNIT then ()
		       else typeError pos "Unit type is required";
		     {exp=(), ty=T.UNIT}
		   end			   
		)

	      |trExp (A.WhileExp{test, body, pos}) =
	      	    ( checkInt (trExp(test), pos);
		    looplevel:= !looplevel+1;
		    let val {exp=_, ty=ty1}=trExp (body);		     	
		    in
			if ty1=T.UNIT then ()
                     	     else typeError pos "Unit type is required";
			looplevel:= !looplevel-1;
			{exp = (), ty = T.UNIT}			 	      
		     end		    
		    )
             |trExp (A.ForExp {var, escape=escape, lo, hi, body, pos})=	      	     
		      let
			 val venv'=S.enter(venv,var, V.VarEntry{access=X.allocLocal level(!escape),ty=T.INT})
			 val {exp=exp, ty=ty1}=transExp(venv', tenv, level) body
		      in 
		      	 looplevel:= !looplevel+1;
		      	 checkInt (trExp(lo), pos);
		         checkInt (trExp(hi), pos);
		      	 if ty1<>T.UNIT then typeError pos "Unit type required" else () ;
			 looplevel:= !looplevel-1;
			 {exp=(), ty=T.UNIT}
	     	       end
	     |trExp (A.BreakExp pos)=
	     	    (if !looplevel>0 then () 
		     else typeError pos "break not within a loop";
		     {exp=(), ty=Types.UNIT})
             |  trExp (A.SeqExp []) = {exp=(), ty=T.UNIT}
             |  trExp (A.SeqExp ((exp,pos)::nil)) = trExp exp
             |  trExp (A.SeqExp ((exp,pos)::rest)) = (trExp exp; trExp (A.SeqExp rest))
 	     |  trExp (A.VarExp i) = trVar( i, level)
	     |  trExp (A.AssignExp {var=i, exp=exp, pos=pos})=
	     	     (let val {exp=_, ty=ty1}=trVar(i, level);
		          val  {exp=_, ty=ty2}=trExp(exp)
		      in 
		      	 if assignable(ty1, ty2) then ()
                 	 else typeError pos  "types don't match"; {exp=(), ty=T.UNIT}	
		      end)
	      
	      | trExp (A.CallExp{func=s, args=args,pos=pos})=
	      	(case S.look(venv,s) of
		      NONE => (typeError pos "function undefined"; {exp=(), ty=T.INT})
		      |SOME  (V.FunEntry {level=level,label=name,formals=formals, result=resultty}) =>  
		      	    ( (map (fn (argexp,formalty) => 
			    	 let val {exp,ty}=trExp argexp
				 in
					      if assignable (ty ,formalty) 
						       then () 
                                               else typeError pos "argument type does not match";
					       exp
			         end)
                                 (ListPair.zip (args,formals) ));	
				{exp=(), ty=resultty} )
		)
		| trExp (A.ArrayExp {typ=typ, size=size, init=init, pos=pos})=
		  let 
		      val {exp=_, ty=tyinit}=trExp(init);
		  in
			checkInt (trExp size, pos);
		   	case S.look(tenv,typ) of 
		   	     NONE => (typeError pos "undeclared  type"; {exp=(), ty=T.INT})
			     |SOME (T.ARRAY (ty,ref ()))=>                  
			     	   if ty<>tyinit then ( typeError pos "type of the array and initialization value don't match"; {exp=(),ty=T.INT})
				   else ({exp=(), ty=T.ARRAY (ty,ref ())})
	          end
	      | trExp (A.RecordExp{fields=fields, typ=typ,pos})=
	       ( case S.look(tenv,typ) of
		NONE =>( typeError pos "undefined variable"; {exp=(),ty=T.INT})
	        |SOME (T.RECORD( fieldlist ,ref())) =>
 		      let val fieldlist2=(map (fn (symbol,exp,pos) => 
			    	 let val {exp,ty}=trExp exp
				 in
					(symbol,ty)
			         end)
                                 (fields ))
			   val pairfieldlist=ListPair.zip (fieldlist,fieldlist2)
			   fun fl ((fl11, fl12),(fl21,fl22)) =( 		    	
					      if assignable(fl12 ,fl22) andalso (fl11= fl21)
						       then () 
                                               else typeError pos "records fields do not match";
					       fl11)
		      in
			        map fl  pairfieldlist;
				 {exp=(), ty=T.RECORD(fieldlist, ref())}
		      end 
		)
	       | trExp (A.LetExp{decs=decs, body=body, pos=pos}) =
		let 
		fun transDecs(venv, tenv, nil, level) = {venv=venv, tenv=tenv}
         	    | transDecs(venv, tenv, dec::rest,level) =
           	     let
			val {venv=venv2, tenv=tenv2} = transDec(venv, tenv, dec, level)
            	      in
               	       transDecs(venv2, tenv2, rest, level) 
            	      end
	  
		 val   {venv = venv', tenv=tenv'} = transDecs (venv, tenv, decs, level)
		in transExp(venv', tenv', level) body
		end

and 		trVar (A.SimpleVar(id,pos),level) =
		( case S.look (venv, id)
		   of SOME (V.VarEntry{access,ty}) => {exp = (), ty = actualTy (ty,pos)}
		    | NONE => ( E.error pos ("undefined variable: " ^ (S.name id))
			      ; { exp=(), ty=T.INT }
			      )
		)
	   
	
in trExp
end

 
    (* transProg A.exp -> unit *)
   
fun transProg prog =
    let 
        val c=C.findEscape(prog)
	val {exp=_, ty=_} = transExp(V.base_venv, V.base_tenv, X.outermost) prog
    in () 
    end
end
